home *** CD-ROM | disk | FTP | other *** search
/ The Programmer Disk / The Programmer Disk (Microforum).iso / xpro / qb2 / pro20 / qb4dir.bas < prev    next >
Encoding:
BASIC Source File  |  1988-09-16  |  10.0 KB  |  286 lines
  1. '* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  2. '*                                                                         *
  3. '*                             QB4DIR.BAS                                  *
  4. '*                                                                         *
  5. '*                      Disk Directory Routines                            *
  6. '*               written with Microsoft QuickBASIC v4.00b                  *
  7. '*                                                                         *
  8. '* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  9. '*                                                                         *
  10. '*  NOTE:                                                                  *
  11. '*                                                                         *
  12. '*  THIS  PROGRAM,  ITS USE,  OPERATION,  AND SUPPORT IS PROVIDED "AS IS"  *
  13. '*  WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING,  *
  14. '*  BUT NOT LIMITED TO,  THE IMPLIED  WARRANTIES  OF  MERCHANTABILITY AND  *
  15. '*  FITNESS FOR A PARTICULAR PURPOSE.   THE ENTIRE RISK AS TO THE QUALITY  *
  16. '*  AND PERFORMANCE OF THIS PROGRAM IS WITH THE USER.   IN NO EVENT SHALL  *
  17. '*  MICROSOFT BE LIABLE FOR  DAMAGES INCLUDING,  WITHOUT LIMITATION,  ANY  *
  18. '*  LOST PROFITS,  LOST  SAVINGS,  OR OTHER  INCIDENTAL OR  CONSEQUENTIAL  *
  19. '*  DAMAGES ARISING FROM  THE USE OR INABILITY TO USE THIS PROGRAM,  EVEN  *
  20. '*  IF MICROSOFT HAS BEEN ADVISED OF THE  POSSIBILTY OF SUCH DAMAGES,  OR  *
  21. '*  FOR ANY CLAIM BY ANY OTHER PARTY.                                      *
  22. '*                                                                         *
  23. '* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  24. '
  25. '
  26. 'QuickBASIC 4.0 Disk Directory routine
  27. 'By Kyle Sparks, Microsoft 1988
  28. '
  29. 'for use inside the QB4 environment, must have QB.QLB Quick Library loaded
  30. '
  31. '************************************************************************
  32.  
  33.    DEFINT A-Z
  34.  
  35. '----------------------------- Define Types -----------------------------
  36.  
  37.    TYPE FileFindBuf                   'DTA Buffer
  38.       DOS            AS STRING * 19   'first 20 bytes reserved
  39.       CreateTime     AS STRING * 1    'by DOS
  40.       Attributes     AS INTEGER       'Attribute of file
  41.       AccessTime     AS INTEGER       'Last access time of file
  42.       AccessDate     AS INTEGER       'Last access date of file
  43.       FileSize       AS LONG          'Size of file in bytes
  44.       FileName       AS STRING * 13   'File name XXXXXXXX.XXX
  45.    END TYPE
  46.  
  47.    TYPE Register                      'Type for use with Interrupt
  48.       ax    AS INTEGER
  49.       bx    AS INTEGER
  50.       cx    AS INTEGER
  51.       dx    AS INTEGER
  52.       bp    AS INTEGER
  53.       si    AS INTEGER
  54.       di    AS INTEGER
  55.       flags AS INTEGER
  56.       ds    AS INTEGER
  57.       es    AS INTEGER
  58.    END TYPE
  59.  
  60. '------------------------- Dimension Variables --------------------------
  61.  
  62.    DIM BUFFER AS FileFindBuf
  63.    DIM InReg AS Register, OutReg AS Register
  64.    DIM k(255) AS STRING
  65.  
  66. '-------------------------- Declare Procedures --------------------------
  67.                                                
  68.    DECLARE FUNCTION FirstFM (Path$, FA%)        'Searches for First File Match
  69.    DECLARE FUNCTION GetDrive$ ()                'Gets default drive
  70.    DECLARE FUNCTION GetPath$ (Drive$)           'Gets default path on Drive$
  71.    DECLARE FUNCTION NextFM ()                   'Searches for Next File Match
  72.    DECLARE FUNCTION WDate$ (d%)                 'Converts Date
  73.    DECLARE FUNCTION WTime$ (t%)                 'Converts Time
  74.    DECLARE SUB DIR (Path$, k() AS STRING, FA%)  'Dir Control Module
  75.    DECLARE SUB InitBuf (BUFFER AS FileFindBuf)  'Initializes buffer
  76.    DECLARE SUB SetDTA (BUF AS ANY)              'Sets the Data Transfer Area
  77.  
  78. DECLARE SUB Interrupt (IntNo%, InRegs AS Register, OutRegs AS Register)
  79. DECLARE SUB InterruptX (IntNo%, InRegs AS Register, OutRegs AS Register)
  80.  
  81. '------------------------------------------------------------------------
  82.  
  83. FA% = 0                                        'File Attribute to search for
  84.                                                '&h00 = Normal
  85.                                                '&h08 = Volume Label Only
  86.                                                '&h10 = Files and Directories
  87.  
  88. DIR "*.bas", k(), FA%                          'Get Directory
  89.  
  90. SUB DIR (Path$, DirArray() AS STRING, FA%)
  91. '------------------------------------------------------------------------
  92. '  procedure DIR manages other procedures and loads an array with the
  93. '  file names and information for files that match the search string.
  94. '
  95. '  Path$ is the search string for the DIR
  96. '
  97. '------------------------------------------------------------------------
  98.  
  99. DIM BUFFER AS FileFindBuf
  100.  
  101. SetDTA BUFFER
  102.  
  103. Counter = 0
  104. IF (FirstFM(Path$, FA%) = 0) THEN
  105.   DO
  106.  
  107.     Counter = Counter + 1
  108.     s = INSTR(BUFFER.FileName, ".")
  109.  
  110.     DirArray(Counter) = SPACE$(43)
  111.     MID$(DirArray(Counter), 1, LEN(BUFFER.FileName)) = BUFFER.FileName
  112.     IF BUFFER.Attributes = 4096 THEN
  113.        MID$(DirArray(Counter), 15, 9) = "<DIR>"
  114.     ELSE
  115.        MID$(DirArray(Counter), 15, 8) = SPACE$(8 - LEN(RTRIM$(LTRIM$(STR$(BUFFER.FileSize))))) + RTRIM$(LTRIM$(STR$(BUFFER.FileSize)))
  116.     END IF
  117.    
  118.     MID$(DirArray(Counter), 25, 10) = WDate$(BUFFER.AccessDate)
  119.     MID$(DirArray(Counter), 38, 6) = WTime$(BUFFER.AccessTime)
  120.  
  121.     InitBuf BUFFER                 'Clear Buffer
  122.  
  123.     LOOP WHILE (NextFM = 0) AND Counter < 255
  124.  
  125. END IF
  126.  
  127. END SUB
  128.  
  129. FUNCTION FirstFM (Path$, FA%)                 'Find First Match
  130. '------------------------------------------------------------------------
  131. '  function FirstFM returns a zero if the search for first file match
  132. '  was successful.
  133. '------------------------------------------------------------------------
  134.   
  135.    DIM InReg AS Register, OutReg AS Register
  136.    InReg.ax = &H4E00
  137.    InReg.cx = FA%
  138.    FileName$ = Path$ + CHR$(0)
  139.    InReg.dx = SADD(FileName$)
  140.    Interrupt &H21, InReg, OutReg              'Find First Match
  141.    FirstFM = OutReg.ax
  142.  
  143. END FUNCTION
  144.  
  145. FUNCTION GetDrive$
  146. '------------------------------------------------------------------------
  147. '  function GetDrive$ returns the current active DOS drive letter.
  148. '------------------------------------------------------------------------
  149.  
  150.    DIM regs AS Register
  151.    regs.ax = &H1900
  152.    Interrupt &H21, regs, regs
  153.    GetDrive$ = CHR$(65 + regs.ax MOD 256)
  154.  
  155. END FUNCTION
  156.  
  157. FUNCTION GetPath$ (Drive$)
  158. '------------------------------------------------------------------------
  159. '  function GetPath$ returns the current active DOS path on the specified
  160. '------------------------------------------------------------------------
  161.  
  162.    DIM regs AS Register, sb AS STRING * 64
  163.    regs.ax = &H4700
  164.    regs.dx = ASC(Drive$) - 64
  165.    regs.ds = VARSEG(sb)
  166.    regs.si = VARPTR(sb)
  167.    InterruptX &H21, regs, regs
  168.    GetPath$ = LEFT$(sb, INSTR(sb, CHR$(0)) - 1)
  169.  
  170. END FUNCTION
  171.  
  172. SUB InitBuf (BUFFER AS FileFindBuf) STATIC
  173. '------------------------------------------------------------------------
  174. '  procedure InitBuf initializes the DTA buffer.
  175. '------------------------------------------------------------------------
  176.  
  177. '    the first 20 bytes are reserved for DOS and are unchanged
  178.      BUFFER.CreateTime = " "
  179.      BUFFER.Attributes = 0
  180.      BUFFER.AccessTime = 0
  181.      BUFFER.AccessDate = 0
  182.      BUFFER.FileSize = 0
  183.      BUFFER.FileName = STRING$(13, 32)
  184.  
  185. END SUB
  186.  
  187. FUNCTION NextFM STATIC
  188. '------------------------------------------------------------------------
  189. '  function NextFM returns a zero if the search for the next file match
  190. '  was successful.
  191. '------------------------------------------------------------------------
  192.  
  193.    DIM InReg AS Register, OutReg AS Register
  194.    InReg.ax = &H4F00
  195.    InReg.cx = FA%
  196.    FileName$ = Path$ + CHR$(0)
  197.    InReg.dx = SADD(FileName$)
  198.    Interrupt &H21, InReg, OutReg
  199.    NextFM = OutReg.ax AND &HF
  200.  
  201. END FUNCTION
  202.  
  203. SUB SetDTA (BUFFER AS FileFindBuf) STATIC
  204. '------------------------------------------------------------------------
  205. '  procedure SetDTA sets up the Disk Transfer Area, where the file info
  206. '  for each file will be stored.
  207. '------------------------------------------------------------------------
  208.   
  209.    DIM InReg AS Register, OutReg AS Register
  210.   
  211.    InitBuf BUFFER
  212.   
  213.    InReg.ax = &H1A00
  214.    InReg.ds = VARSEG(BUFFER)
  215.    InReg.dx = VARPTR(BUFFER)
  216.   
  217.    InterruptX &H21, InReg, OutReg
  218.  
  219. END SUB
  220.  
  221. FUNCTION WDate$ (d%) STATIC
  222. '------------------------------------------------------------------------
  223. '  function WDate$ converts the encoded date returned by FindFirst or
  224. '  FindNext in BUFFER.Date into a date that is understandable.
  225. '------------------------------------------------------------------------
  226.  
  227.    DIM dl AS LONG
  228.   
  229.    IF d% >= 0 THEN
  230.       dl = d%
  231.    ELSE
  232.       dl = 65536 + d%
  233.    END IF
  234.    mn = (dl \ 2 ^ 5) AND (&HF)
  235.    IF mn < 10 THEN
  236.       mn$ = "0" + LTRIM$(STR$(mn))
  237.    ELSE
  238.       mn$ = LTRIM$(STR$(mn))
  239.    END IF
  240.    dy = dl AND (&H1F)
  241.    IF dy < 10 THEN
  242.       dy$ = "0" + LTRIM$(STR$(dy))
  243.    ELSE
  244.       dy$ = LTRIM$(STR$(dy))
  245.    END IF
  246.    yr$ = STR$((dl \ 2 ^ 9) + 1980)
  247.    WDate$ = mn$ + "/" + dy$ + "/" + LTRIM$(yr$)
  248.   
  249. END FUNCTION
  250.  
  251. FUNCTION WTime$ (d%) STATIC
  252. '------------------------------------------------------------------------
  253. '  function WDate$ converts the encoded time returned by FindFirst or
  254. '  FindNext in BUFFER.Time into a time that is understandable.
  255. '------------------------------------------------------------------------
  256.  
  257.    DIM dl AS LONG
  258.   
  259.    IF d% >= 0 THEN
  260.       dl = d%
  261.    ELSE
  262.       dl = 65536 + d%
  263.    END IF
  264.    hr = (dl \ 2 ^ 11) AND (&H1F)
  265.    IF hr >= 12 THEN
  266.       pf$ = "p"
  267.       hr = hr - 12
  268.       IF hr = 0 THEN hr = 12
  269.    ELSE
  270.       pf$ = "a"
  271.    END IF
  272.    IF hr < 10 THEN
  273.       hr$ = "0" + LTRIM$(STR$(hr))
  274.    ELSE
  275.       hr$ = LTRIM$(STR$(hr))
  276.    END IF
  277.    mt = ((dl \ 2 ^ 5) AND (&H3F))
  278.    IF mt < 10 THEN
  279.       mt$ = "0" + LTRIM$(STR$(mt))
  280.    ELSE
  281.       mt$ = LTRIM$(STR$(mt))
  282.    END IF
  283.    WTime$ = LTRIM$(hr$) + ":" + mt$ + pf$
  284. END FUNCTION
  285.  
  286.